home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / trace.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-06-05  |  12.5 KB  |  302 lines
  1. ;; Tracer
  2. ;; Bruno Haible 13.2.1990, 15.3.1991, 4.4.1991
  3.  
  4. ; (TRACE) liefert Liste der getraceten Funktionen
  5. ; (TRACE fun ...) tracet die Funktionen fun, ... zusätzlich.
  6. ; Format für fun:
  7. ;   Entweder ein Symbol
  8. ;        symbol
  9. ;   oder eine Liste aus einem Symbol und einigen Keyword-Argumenten (paarig!)
  10. ;        (symbol
  11. ;          [:suppress-if form]   ; kein Trace-Output, solange form erfüllt ist
  12. ;          [:step-if form]       ; Trace geht in den Stepper, falls form erfüllt
  13. ;          [:pre form]           ; führt vor Funktionsaufruf form aus
  14. ;          [:post form]          ; führt nach Funktionsaufruf form aus
  15. ;          [:pre-break-if form]  ; Trace geht vor Funktionsaufruf in die Break-Loop,
  16. ;                                ; falls form erfüllt
  17. ;          [:post-break-if form] ; Trace geht nach Funktionsaufruf in die Break-Loop,
  18. ;                                ; falls form erfüllt
  19. ;          [:pre-print form]     ; gibt die Werte von form vor Funktionsaufruf aus
  20. ;          [:post-print form]    ; gibt die Werte von form nach Funktionsaufruf aus
  21. ;          [:print form]         ; gibt die Werte von form vor und nach Funktionsaufruf aus
  22. ;        )
  23. ;   In all diesen Formen kann auf *TRACE-FUNCTION* (die Funktion selbst)
  24. ;   und *TRACE-ARGS* (die Argumente an die Funktion)
  25. ;   und *TRACE-FORM* (der Funktions-/Macro-Aufruf als Form)
  26. ;   und nach Funktionsaufruf auch auf *TRACE-VALUES* (die Liste der Werte
  27. ;   des Funktionsaufrufs) zugegriffen werden,
  28. ;   und mit RETURN kann der Aufruf mit gegebenen Werten verlassen werden.
  29. ; (UNTRACE) liefert Liste der getraceten Funktionen, streicht sie alle.
  30. ; (UNTRACE symbol ...) streicht symbol, ... aus der Liste der getraceten
  31. ;   Funktionen.
  32. ; TRACE und UNTRACE sind auch auf Macros anwendbar, nicht jedoch auf lokal
  33. ;   definierte Funktionen und Macros.
  34.  
  35. (in-package "LISP")
  36. (export '(trace untrace
  37.           *trace-function* *trace-args* *trace-form* *trace-values*
  38. )        )
  39. (in-package "SYSTEM")
  40.  
  41. (proclaim '(special *trace-function* *trace-args* *trace-form* *trace-values*))
  42. (defvar *traced-functions* nil) ; Liste der momentan getraceden Symbole
  43.   ; Solange ein Symbol getraced ist, enthält
  44.   ; die Property sys::traced-definition den alten Inhalt der Funktionszelle,
  45.   ; die Property sys::tracing-definition den neuen Inhalt der Funktionszelle,
  46.   ; und ist das Symbol Element der Liste *traced-functions*.
  47.   ; Währenddessen kann sich der Inhalt der Funktionszelle jedoch ändern!
  48.   ; Jedenfalls gilt stets:
  49.   ;        (and (fboundp symbol)
  50.   ;             (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  51.   ;        )
  52.   ; ===>   (member symbol *traced-functions* :test #'eq)
  53.   ; <==>   (get symbol 'sys::traced-definition)
  54. (defvar *trace-level* 0) ; Verschachtelungstiefe bei der Trace-Ausgabe
  55.  
  56. ; Funktionen, die der Tracer zur Laufzeit aufruft und die der Benutzer
  57. ; tracen könnte, müssen in ihrer ungetraceden Form aufgerufen werden.
  58. ; Statt (fun arg ...) verwende daher (SYS::%FUNCALL '#,#'fun arg ...)
  59. ; oder (SYS::%FUNCALL (LOAD-TIME-VALUE #'fun) arg ...).
  60. ; Dies gilt für alle hier verwendeten Funktionen von #<PACKAGE LISP> außer
  61. ; CAR, CDR, CONS, APPLY, VALUES-LIST (die alle inline compiliert werden).
  62.  
  63. (defmacro trace (&rest funs)
  64.   (if (null funs)
  65.     '*traced-functions*
  66.     (cons 'append
  67.       (mapcar #'(lambda (fun)
  68.                   (if (atom fun) (trace1 fun) (apply #'trace1 fun))
  69.                 )
  70.               funs
  71.     ) )
  72. ) )
  73.  
  74. (defun trace1 (symbol &key (suppress-if nil) (step-if nil)
  75.                            (pre nil) (post nil)
  76.                            (pre-break-if nil) (post-break-if nil)
  77.                            (pre-print nil) (post-print nil) (print nil)
  78.                       &aux (old-function (gensym)) (macro-flag (gensym))
  79.               )
  80.   (unless (symbolp symbol)
  81.     (error #+DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  82.            #+ENGLISH "~S: function name should be a symbol, not ~S"
  83.            #+FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S"
  84.            'trace symbol
  85.   ) )
  86.   `(block nil
  87.      (unless (fboundp ',symbol) ; Funktion überhaupt definiert?
  88.        (warn #+DEUTSCH "~S: Funktion ~S ist nicht definiert."
  89.              #+ENGLISH "~S: undefined function ~S"
  90.              #+FRANCAIS "~S : La fonction ~S n'est pas définie."
  91.              'trace ',symbol
  92.        )
  93.        (return nil)
  94.      )
  95.      (when (special-form-p ',symbol) ; Special-Form: nicht tracebar
  96.        (warn #+DEUTSCH "~S: Special-Form ~S kann nicht getraced werden."
  97.              #+ENGLISH "~S: cannot trace special form ~S"
  98.              #+FRANCAIS "~S : La forme spéciale ~S ne peut pas être tracée."
  99.              'trace ',symbol
  100.        )
  101.        (return nil)
  102.      )
  103.      (let* ((,old-function (symbol-function ',symbol))
  104.             (,macro-flag (consp ,old-function)))
  105.        (unless (eq ,old-function (get ',symbol 'sys::tracing-definition)) ; schon getraced?
  106.          (setf (get ',symbol 'sys::traced-definition) ,old-function)
  107.          (pushnew ',symbol *traced-functions*)
  108.        )
  109.        (format t #+DEUTSCH "~&;; ~:[Funktion~;Macro~] ~S wird getraced."
  110.                  #+ENGLISH "~&;; Tracing ~:[function~;macro~] ~S."
  111.                  #+FRANCAIS "~&;; Traçage ~:[de la fonction~;du macro~] ~S."
  112.                  ,macro-flag ',symbol
  113.        )
  114.        (replace-in-fenv (get ',symbol 'sys::traced-definition) ',symbol
  115.          ,old-function
  116.          (setf (get ',symbol 'sys::tracing-definition)
  117.            (setf (symbol-function ',symbol)
  118.              ; neue Funktion, die die ursprüngliche ersetzt:
  119.              ,(let ((newname (concat-pnames "TRACED-" symbol))
  120.                     (body
  121.                       `((declare (compile) (inline car cdr cons apply values-list))
  122.                         (let ((*trace-level* (trace-level-inc)))
  123.                           (block nil
  124.                             (unless ,suppress-if
  125.                               (trace-pre-output)
  126.                             )
  127.                             ,@(when pre-print
  128.                                 `((trace-print (multiple-value-list ,pre-print)))
  129.                               )
  130.                             ,@(when print
  131.                                 `((trace-print (multiple-value-list ,print)))
  132.                               )
  133.                             ,pre
  134.                             ,@(when pre-break-if
  135.                                 `((when ,pre-break-if (sys::break-loop t)))
  136.                               )
  137.                             (let ((*trace-values*
  138.                                     (multiple-value-list
  139.                                       (if ,step-if
  140.                                         (trace-step-apply)
  141.                                         (apply *trace-function* *trace-args*)
  142.                                  )) ) )
  143.                               ,@(when post-break-if
  144.                                   `((when ,post-break-if (sys::break-loop t)))
  145.                                 )
  146.                               ,post
  147.                               ,@(when print
  148.                                   `((trace-print (multiple-value-list ,print)))
  149.                                 )
  150.                               ,@(when post-print
  151.                                   `((trace-print (multiple-value-list ,post-print)))
  152.                                 )
  153.                               (unless ,suppress-if
  154.                                 (trace-post-output)
  155.                               )
  156.                               (values-list *trace-values*)
  157.                        )) ) )
  158.                    ))
  159.                 `(if (not ,macro-flag)
  160.                    (function ,newname
  161.                      (lambda (&rest *trace-args*
  162.                               &aux (*trace-form* (make-apply-form ',symbol *trace-args*))
  163.                                    (*trace-function* (get-traced-definition ',symbol))
  164.                              )
  165.                        ,@body
  166.                    ) )
  167.                    (cons 'sys::macro
  168.                      (function ,newname
  169.                        (lambda (&rest *trace-args*
  170.                                 &aux (*trace-form* (car *trace-args*))
  171.                                      (*trace-function* (cdr (get-traced-definition ',symbol)))
  172.                                )
  173.                          ,@body
  174.                    ) ) )
  175.                  )
  176.               )
  177.      ) ) ) )
  178.      '(,symbol)
  179.    )
  180. )
  181.  
  182. ;; Hilfsfunktionen:
  183. ; Funktionsreferenzen, die vom LABELS bei DEFUN kommen, ersetzen:
  184. (defun replace-in-fenv (fun symbol old new)
  185.   (when (and (sys::closurep fun) (not (compiled-function-p fun)))
  186.     ; interpretierte Closure
  187.     (let ((fenv (sys::%record-ref fun 5))) ; Funktions-Environment
  188.       (when fenv ; falls nichtleer, durchlaufen:
  189.         (do ((l (length fenv)) ; l = 2 * Anzahl der Bindungen + 1
  190.              (i 1 (+ i 2)))
  191.             ((eql i l))
  192.           (when (and (eq (svref fenv (- i 1)) symbol) (eq (svref fenv i) old))
  193.             (setf (svref fenv i) new)
  194.         ) )
  195. ) ) ) )
  196. ; Nächsthöheres Trace-Level liefern:
  197. (defun trace-level-inc ()
  198.   (%funcall '#,#'1+ *trace-level*)
  199. )
  200. ; Ursprüngliche Funktionsdefinition holen:
  201. (defun get-traced-definition (symbol)
  202.   (%funcall '#,#'get symbol 'sys::traced-definition)
  203. )
  204. ; Anwenden, aber durchsteppen:
  205. (defun trace-step-apply ()
  206.   ;(eval `(step (apply ',*trace-function* ',*trace-args*)))
  207.   (%funcall '#,#'eval
  208.     (cons 'step
  209.      (cons
  210.        (cons 'apply
  211.         (cons (cons 'quote (cons *trace-function* nil))
  212.          (cons (cons 'quote (cons *trace-args* nil))
  213.           nil
  214.        )))
  215.       nil
  216.     ))
  217.   )
  218. )
  219. ; Eval-Form bauen, die einem Apply (näherungsweise) entspricht:
  220. (defun make-apply-form (symbol args)
  221.   (declare (inline cons mapcar))
  222.   (cons symbol
  223.     (mapcar #'(lambda (arg)
  224.                 ;(list 'quote arg)
  225.                 (cons 'quote (cons arg nil))
  226.               )
  227.             args
  228.   ) )
  229. )
  230. ; Output vor Aufruf, benutzt *trace-level* und *trace-form*
  231. (defun trace-pre-output ()
  232.   (%funcall '#,#'terpri *trace-output*)
  233.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  234.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  235.   (%funcall '#,#'prin1 *trace-form* *trace-output*)
  236. )
  237. ; Output nach Aufruf, benutzt *trace-level*, *trace-form* und *trace-values*
  238. (defun trace-post-output ()
  239.   (declare (inline car cdr consp atom))
  240.   (%funcall '#,#'terpri *trace-output*)
  241.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  242.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  243.   (%funcall '#,#'write (car *trace-form*) :stream *trace-output*)
  244.   (%funcall '#,#'write-string " ==> " *trace-output*)
  245.   (trace-print *trace-values* nil)
  246. )
  247. ; Output einer Liste von Werten:
  248. (defun trace-print (vals &optional (nl-flag t))
  249.   (when nl-flag (%funcall '#,#'terpri *trace-output*))
  250.   (when (consp vals)
  251.     (loop
  252.       (let ((val (car vals)))
  253.         (%funcall '#,#'prin1 val *trace-output*)
  254.       )
  255.       (setq vals (cdr vals))
  256.       (when (atom vals) (return))
  257.       (%funcall '#,#'write-string ", " *trace-output*)
  258. ) ) )
  259.  
  260. (defmacro untrace (&rest funs)
  261.   `(mapcan #'untrace1 ,(if (null funs) `(copy-list *traced-functions*) `',funs))
  262. )
  263.  
  264. (defun untrace1 (symbol)
  265.   (unless (symbolp symbol)
  266.     (error #+DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  267.            #+ENGLISH "~S: function name should be a symbol, not ~S"
  268.            #+FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S"
  269.            'untrace symbol
  270.   ) )
  271.   (let ((old-definition (get symbol 'sys::traced-definition)))
  272.     (prog1
  273.       (if old-definition
  274.         ; symbol war getraced
  275.         (progn
  276.           (if (and (fboundp symbol)
  277.                    (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  278.               )
  279.             (progn
  280.               (replace-in-fenv old-definition symbol (symbol-function symbol) old-definition)
  281.               (setf (symbol-function symbol) old-definition)
  282.             )
  283.             (warn #+DEUTSCH "~S: ~S war getraced und wurde umdefiniert!"
  284.                   #+ENGLISH "~S: ~S was traced and has been redefined!"
  285.                   #+FRANCAIS "~S : ~S était tracée et a été redéfinie!"
  286.                   'untrace symbol
  287.           ) )
  288.           `(,symbol)
  289.         )
  290.         ; symbol war nicht getraced
  291.         '()
  292.       )
  293.       (untrace2 symbol)
  294. ) ) )
  295.  
  296. (defun untrace2 (symbol)
  297.   (remprop symbol 'sys::traced-definition)
  298.   (remprop symbol 'sys::tracing-definition)
  299.   (setq *traced-functions* (delete symbol *traced-functions* :test #'eq))
  300. )
  301.  
  302.